home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The Original Shareware 1.1
/
The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso
/
19
/
madtrb40.zip
/
FILES.INC
< prev
next >
Wrap
Text File
|
1986-05-18
|
8KB
|
217 lines
Const
INT24Err : Boolean = False;
INT24ErrCode : Byte = 0;
OldINT24: Array [1..2] Of Integer=(0,0);
Var
RegisterSet: Record Case Integer Of
1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
End;
{ The Interupt 24 routines are designed to trap critical errors that generate }
{ the ABORT, RETRY, IGNORE messages. These were originally written by }
{ Marshall Brain and were revised by Bela Lubkin, Borland International }
{ Technical Support. }
Procedure INT24;
Begin
{ To understand this routine, you will need to read
the description on Interrupt 24 in the DOS manual.
It also helps to examine the generated code under DEBUG. }
Inline
($2E/$C6/$06/ INT24Err /$01/$89/$EC/$83/$C4/$08/$89/$F8/$2E/$A2/
INT24ErrCode /$58/$B0/$FF/$5B/$59/$5A/$5E/$5F/$5D/$1F/$07/$CF);
{ Turbo: PUSH BP (Save caller's stack frame
MOV BP,SP Set up this procedure's stack frame
PUSH BP ?)
Inline: MOV BYTE CS:[INT24Err],1 Set INT24Err to True
MOV SP,BP Get correct SP; ADD: Discard saved
ADD SP,8 BP, INT 24 return address & flags
MOV AX,DI Get INT 24 error code
MOV CS:[INT24ErrCode],AL Save it in INT24ErrCode
POP AX Pop all registers
MOV AL,0FFH Set FCB call error flag:
POP BX will cause Turbo I/O error on file
POP CX operations, no error on character
POP DX operations
POP SI
POP DI
POP BP
POP DS
POP ES
IRET Return to next instruction }
End;
Procedure INT24On; { Enable INT 24 trapping }
Begin
INT24Err:=False;
With RegisterSet Do
Begin
AX:=$3524;
MsDos(RegisterSet);
If (OldINT24[1] Or OldINT24[2])=0 Then
Begin
OldINT24[1]:=ES;
OldINT24[2]:=BX;
End;
DS:=CSeg;
DX:=Ofs(INT24);
AX:=$2524;
MsDos(RegisterSet);
End;
End;
Procedure INT24Off; { Disable INT 24 trapping. Should be done at the end
of the program, if you plan to run the program from
within the Turbo compiler. If the INT 24 handler is
left in place, and the compiler gets a critical
error, the system is likely to crash. }
Begin
INT24Err:=False;
If OldINT24[1]<>0 Then
With RegisterSet Do
Begin
DS:=OldINT24[1];
DX:=OldINT24[2];
AX:=$2524;
MsDos(RegisterSet);
End;
OldINT24[1]:=0;
OldINT24[2]:=0;
End;
Procedure IOCheck (Var IOErr : Integer; Var ErrTxt : Str80);
{ This procedure checks IOResult for an error code. If ErrOut is true then}
{ an error message is returned in ErrTxt, the error number is returned in}
{ the variable IOErr for further processing.}
Var
St : string[3];
Begin
IOErr := IOResult;
If INT24Err Then
Begin
IOErr :=IOErr+256*INT24ErrCode;
INT24On;
End;
If IOErr <> 0 then
begin
Case IOErr of
$01 : ErrTxt := 'File does not exist.';
$02 : ErrTxt := 'File not open for input.';
$03 : ErrTxt := 'File not open for output.';
$04 : ErrTxt := 'File not open.';
$05 : ErrTxt := 'Can''t read from this file.';
$06 : ErrTxt := 'Can''t write to this file.';
$10 : ErrTxt := 'Error in numeric format.';
$20 : ErrTxt := 'Operation not allowed on a logical device.';
$21 : ErrTxt := 'Not allowed in direct mode.';
$22 : ErrTxt := 'Assign to standard files not allowed.';
$90 : ErrTxt := 'Record length mismatch.';
$91 : ErrTxt := 'Seek beyond end of file.';
$99 : ErrTxt := 'Unexpected end of file.';
$F0 : ErrTxt := 'Disk write error.';
$F1 : ErrTxt := 'Directory is full.';
$F2 : ErrTxt := 'File size overflow.';
$FF : ErrTxt := 'File disappeared, can''t close.';
256 : ErrTxt := 'Attempt to write on write protected disk.';
512 : ErrTxt := 'Drive not ready, drive door open or bad drive.';
752 : ErrTxt := 'Drive not ready, drive door open or bad drive.';
768 : ErrTxt := 'Unknown unit, internal dos error.';
1024 : ErrTxt := 'Unknown command, internal dos error.';
1280 : ErrTxt := 'Data error (CRC), bad sector or drive.';
1536 : ErrTxt := 'Bad request structure length, internal dos error.';
1792 : ErrTxt := 'Seek error, bad disk or drive.';
2048 : ErrTxt := 'Unknown media type, bad disk or drive.';
2304 : ErrTxt := 'Sector not found, bad disk or drive.';
2560 : ErrTxt := 'Printer not ready.';
2816 : ErrTxt := 'Write fault, character device not ready.';
3072 : ErrTxt := 'Read fault, character device not ready';
3328 : ErrTxt := 'General failure, (..your guess..) several meanings.';
else begin
Str (IOErr, St);
ErrTxt := 'Unknown I/O error: ' + St;
end; {Str/ErrTxt}
end; {Case of}
end {begin}
else
ErrTxt := '';
end; {IOCheck}
Procedure OpenFile(Var FilVar : FileType; Var FileOpenErr : Str80;
Extension : Str4);
{ This procedure opens a file and assigns it to the file type FileVar. }
{ The input variable FileOpenErr is used to define the type of file to }
{ open by assigning it to (N)ew, (O)ld, or (A)dd. }
{ (N)ew, (O)ld and (A)dd' will create a new file, open an old file or }
{ open an old file and set the pointer to the end of the data respectively}
{ For example by assigning FileOpenErr := (N)ew; a new file }
{ will be created. If a file with the same name is }
{ found the user will be asked if the file is to be overwritten. }
{ If an error is encountered in opening the file the text description of }
{ the error will be returned in the variable FileOpenErr. }
{ A constant extension may be passed to this routine. The constant }
{ extension will be superceded by any extension entered from the keyboard.}
{ If no extension is passes to the routine and none is entered from the }
{ keyboard then a null extension is used: '. ' }
Var
Filename : Str80;
NewOldAdd : Char;
IOErr : Integer;
Ans : integer;
Begin
{$V-}
LowToUp(FileOpenErr);
NewOldAdd := copy(FileOpenErr,1,1);
Write('Enter name of file: ');
Readln(Filename);
If Pos('.',Filename) = 0 then
begin
If Extension[1] <> '.' then Extension[1] := '.';
Filename := Filename + Extension;
end;
{$I-}
Assign(FilVar, Filename);
Reset(FilVar);
IOCheck(IOErr, FileOpenErr);
Case NewOldAdd of
'N' : begin
If IOErr = $01 then
begin
Rewrite(FilVar);
IOCheck(IOErr,FileOpenErr);
end
else
if IOErr = $00 then
begin
Write('File already exists! Overwrite? (Y/N) ');
Answer('Yes,No',Ans,false);
if Ans = 1 then
begin
FileOpenErr := '';
Rewrite(FilVar);
IOCheck(IOErr,FileOpenErr);
end
else
FileOpenErr := 'File Already Exists!';
end;
end;
'A' : If IOErr = $00 then
Seek(FilVar, FileSize(FilVar));
end; {case}
{$I+}
{$V+}
End; {OpenFile}
Procedure CloseFile(Var FilVar: FileType; Var FileErr: Str80);
Var
IOErr : integer;
Begin
{I-}
Close(FilVar);
{I+}
IOCheck(IOErr,FileErr);
End; {CloseFile}